(FILECREATED "14-OCT-73 16:35:54" RECORD)


(LISPXPRINT (QUOTE RECORDVARS) T)
(RPAQQ RECORDVARS ((FNS TYPERECORD RECORD RECORD1 CLISPRECORD RECORDECL
RECCOMPOSE0 'CAR 'CDR 'CONS RECCOMPOSE1 RECCOMPOSE2 MAKECROPFN1 FIELDSIN
/PUTDTST FIELDDEFS MYSUBST MAKERPLAC2 RECRESPELL CLISPNOTRAN GETLOCALDEC
RECLOOK DWIMIFYREC EASYCOMPUTE GLOBALRECORD RECLISPLOOKUP GETSETQ
RECORDERROR SETPACK MAKEALIST CHECKDEFAULT) (PROP CLISPWORD CREATE
create USING using) (PROP PRETTYTYPE RECORDS) (ADDVARS (PRETTYTYPELST
(CHANGEDRECLST RECORDS "records")) (PRETTYMACROS (RECORDS X (E (MAPC
(QUOTE X) (FUNCTION (LAMBDA (Z) (PRINT (SELECTQ (CAR (SETQ Z (
CLISPNOTRAN (OR (LISTP Z) (LISTP (GETP Z (QUOTE RECORD))))))) ((RECORD
TYPERECORD) Z) (ERROR Z "not a record")))))))))) (VARS CRLIST (
RECORDSPLIST (LIST NIL)) (CHANGEDRECLST NIL) (USERRECORDS NIL) (
RECORDTRANFLG T) RECORDREPLACEVALUEFLG CLISPRECORDWORDS (RECORDSUBSTFLG
T)) (BLOCKS (RECORDBLOCK TYPERECORD RECORD RECORD1 CLISPRECORD RECORDECL
CHECKDEFAULT RECCOMPOSE0 'CAR 'CDR 'CONS RECCOMPOSE1 RECCOMPOSE2 
MAKECROPFN1 FIELDSIN /PUTDTST FIELDDEFS MYSUBST MAKERPLAC2 RECRESPELL
CLISPNOTRAN GETLOCALDEC RECLOOK DWIMIFYREC EASYCOMPUTE GLOBALRECORD
RECLISPLOOKUP GETSETQ RECORDERROR SETPACK MAKEALIST (ENTRIES RECORD
TYPERECORD RECCOMPOSE0 CLISPRECORD RECORDECL) (LOCALFREEVARS SUBSTEXPR
ALIST BLIP COPYING FIELDS DECL USINGTYPE) (GLOBALVARS CHANGEDRECLST
CLISPARRAY CLISPTRANFLG CRLIST DFNFLG DWIMFLG FILEPKGFLG 
RECORDREPLACEVALUEFLG RECORDSPLIST RECORDTRANFLG USERRECORDS 
CLISPRECORDWORDS RECORDSUBSTFLG) (SPECVARS VARS REDECLARELST)) (NIL
CLISPNOTRAN (LINKEDFN . T)))))
(DEFINEQ

(TYPERECORD
(NLAMBDA NAME&FIELDS (PROG (TEM) (RECORD1 (CONS (QUOTE TYPERECORD)
NAME&FIELDS)) (AND RECORDTRANFLG (/PUT (SETQ TEM (MKATOM (CONCAT (CAR
NAME&FIELDS) "?"))) (QUOTE MACRO) (CDR (/PUTDTST TEM (LIST (QUOTE
LAMBDA) (QUOTE (RECORDVAR)) (LIST (QUOTE EQ) (QUOTE (CAR RECORDVAR))
(KWOTE (CAR NAME&FIELDS)))))))) (CAR NAME&FIELDS))))

(RECORD
(NLAMBDA NAME&FIELDS (RECORD1 (CONS (QUOTE RECORD) NAME&FIELDS))))

(RECORD1
(LAMBDA (DECL) (PROG (FNF REDECLARELST TEM NAME (FAULTFN (QUOTE TYPE-IN?))
(VARS) (EXPR DECL)) RETRY (SETQ NAME (AND (NLISTP (CADR DECL)) (CADR
DECL))) (COND ((AND (NULL TEM) (NULL (CDDR DECL)) (SETQ TEM (GETP
NAME (QUOTE CLISPRECORD)))) (* Feature: saying (RECORD FOO) if FOO
has a CLISPRECORD PROP, just redeclares FOO - Useful if you edit the
property) (SETQ TEM (CLISPNOTRAN TEM)) (SETQ DECL (CONS (CAR TEM)
(CDR TEM))) (GO RETRY))) (SETQ FNF (RECORDECL DECL T)) (COND (NAME
(COND ((SETQ TEM (GETP NAME (QUOTE CLISPRECORD))) (SETQ REDECLARELST
(CONS (CADR (CLISPNOTRAN TEM)) (CAR (SETQ TEM (RECORDECL TEM T)))))
(* REDCLARELST is used for the MAPHASH) (MAPC (CAR TEM) (FUNCTION
(LAMBDA (X) (/REMPROP X (QUOTE CLISPRECORD))))) (AND (NULL DFNFLG)
(LISPXPRINT (CONS NAME (QUOTE (redeclared))) T)))) (COND (DWIMFLG
(SETQ USERRECORDS (CONS NAME USERRECORDS)) (AND LISPXHIST (UNDOSAVE
(LIST (QUOTE /RPLACA) (QUOTE USERRECORDS) (CDR USERRECORDS)))))) (/PUT
NAME (QUOTE CLISPRECORD) DECL))) (COND ((AND (NULL DFNFLG) FILEPKGFLG)
(FRPLACA (QUOTE CHANGEDRECLST) (CONS (OR NAME DECL) (CAR (QUOTE 
CHANGEDRECLST)))) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACA) (CAR
(QUOTE CHANGEDRECLST))) LISPXHIST)))) (FRPLACD (CDDR FNF) (FIELDDEFS
(CADDR FNF))) (MAPC (CDDDR FNF) (FUNCTION (LAMBDA (FIELD) (PROG NIL
(COND ((AND (GETP (CAR FIELD) (QUOTE CLISPRECORD)) (NOT (FMEMB (CAR
FIELD) REDECLARELST))) (SETQ REDECLARELST (CONS (CAR FIELD) REDECLARELST))
(AND (NULL DFNFLG) (LISPXPRINT (CONS (CAR FIELD) (QUOTE (redeclared)))))))
(ADDSPELL (CAR FIELD) RECORDSPLIST) (/PUT (CAR FIELD) (QUOTE CLISPRECORD)
DECL) (OR RECORDTRANFLG (GLOBALRECORD FIELD)))))) (AND REDECLARELST
CLISPARRAY (MAPHASH CLISPARRAY (FUNCTION (LAMBDA (X Y) (AND X (FMEMB
(CAR Y) (QUOTE (create CREATE fetch FETCH replace REPLACE))) (FMEMB
(CADR Y) REDECLARELST) (/PUTHASH Y NIL CLISPARRAY)))))) (RETURN NAME))))

(CLISPRECORD
(LAMBDA (RECEXPR FIELD SETQFLG) (PROG (TEM1 DECL DECLST) (* Handles
records. When FIELD is NIL, RECEXPR is an expression such as (fetch
--) or (replace --) %. In this case, CLISPRECORD is to do the 
appropriate lookups and construct the appropriate expresson, which
it returns as its value. it should also do the hashing. Note that
even if there are no local declaration, only global ones, it shuld
still construct the expression and hash on it. If there are no local
or global declaration, return NIL. I will handle the error.) RETRY
(COND ((AND FIELD (NLISTP FIELD)) (COND ((AND (SETQ DECLST (GETLOCALDEC
EXPR FAULTFN)) (SETQ TEM1 (CLISPLOOKUP0 FIELD RECEXPR NIL DECLST NIL
(QUOTE RECORDFIELD)))) (* Local declaration, it's ok) (SETQ DECL (
RECORDECL TEM1))) ((FMEMB FIELD (CAR (SETQ DECL (RECORDECL (SETQ TEM1
(GETP FIELD (QUOTE CLISPRECORD))))))) (* Global declaration) (OR 
RECORDTRANFLG (GO GLOBAL))) ((SETQ TEM1 (RECRESPELL FIELD DECLST NIL))
(SETQ FIELD TEM1) (GO RETRY)) ((SETQ TEM1 (GETP FIELD (QUOTE ACCESSFN)))
(AND (ATOM TEM1) (SETQ TEM1 (GETP TEM1 (QUOTE ACCESSFN)))) (RETURN
(COND (SETQFLG (LIST (QUOTE replace) (QUOTE ACCESSFN) (OR (CDR (LISTP
TEM1)) (HELP)) RECEXPR)) (T (LIST (COND ((NLISTP TEM1) TEM1) (T (CAR
TEM1))) RECEXPR))))) (T (RETURN))) (AND SETQFLG (RETURN (LIST (QUOTE
replace) FIELD TEM1 RECEXPR))) (SETQ RECEXPR (LIST (QUOTE fetch) FIELD
(QUOTE of) RECEXPR))) (SETQFLG (OR (EQ (CAR RECEXPR) (QUOTE replace))
(HELP)) (COND ((EQ (CADR RECEXPR) (QUOTE GLOBAL)) (GO GLOBAL2)) ((EQ
(CADR RECEXPR) (QUOTE ACCESSFN)) (FRPLACD (CDDDR RECEXPR) FIELD) (*
Can FRPLACD since this is structure that we built) (RETURN (CDDR RECEXPR))))
(* Second pass - Already done spelling correction) (SETQ DECL (RECORDECL
(SETQ TEM1 (CADDR RECEXPR)))) (FRPLACA (CDDR RECEXPR) (QUOTE of))
(FRPLACD (CDDDR RECEXPR) (CONS (QUOTE with) FIELD))) (T (* User typein)
(SETQ TEM1 (OR (AND (SETQ DECLST (GETLOCALDEC EXPR FAULTFN)) (
CLISPLOOKUP0 (CADR RECEXPR) (CADDDR RECEXPR) NIL DECLST NIL (QUOTE
RECORDFIELD))) (GETP (CADR RECEXPR) (QUOTE CLISPRECORD)) (AND (
RECRESPELL (CADR RECEXPR) DECLST (CDR RECEXPR)) (GO RETRY)) (RETURN)))
(SELECTQ (CADDR RECEXPR) ((of OF)) (OR (FIXSPELL (CADDR RECEXPR) 70
(QUOTE (of OF)) NIL (CDDR RECEXPR) NIL T) (RETURN))) (SELECTQ (CAR
RECEXPR) ((REPLACE replace) (SELECTQ (CAR (CDDDDR RECEXPR)) ((with
WITH)) (OR (FIXSPELL (CAR (CDDDDR RECEXPR)) 70 (QUOTE (with WITH))
NIL (CDDDDR RECEXPR) NIL T) (RETURN)))) ((FETCH fetch)) (HELP))))
(SETQ TEM1 (OR DECL (RECORDECL TEM1) (HELP))) (* Tem1 is the GETHASH
of the RECORD declaration; recexpr is the replace or fetch expression)
(OR (CDDDR TEM1) (FRPLACD (CDDR TEM1) (FIELDDEFS (CADDR TEM1)))) (OR
(SETQ TEM1 (FASSOC (CADR RECEXPR) (CDDDR TEM1))) (HELP)) (CLISPTRAN
RECEXPR (SELECTQ (CAR RECEXPR) ((REPLACE replace) (OR (CDDR TEM1)
(RPLACD (CDR TEM1) (LIST (MAKERPLAC2 (CADR TEM1))))) (SETQ DECL (CONS
(RECLISPLOOKUP (CAR (SETQ TEM1 (CADDR TEM1))) (CADDDR RECEXPR) DECLST
(GETP (CAR TEM1) (QUOTE LISPFN))) (CONS (COND ((LISTP (CADR TEM1))
(PROG ((SUBSTEXPR (LIST (CADDDR RECEXPR)))) (OR (MYSUBST (CADR TEM1))
(HELP)))) (T (CADDDR RECEXPR))) (CDR (CDDDDR RECEXPR))))) (COND (
RECORDREPLACEVALUEFLG (LIST (SELECTQ (CAR DECL) ((RPLACA /RPLACA FRPLACA)
(QUOTE CAR)) ((RPLACD /RPLACD FRPLACD) (QUOTE CDR)) (HELP)) DECL))
(T DECL))) ((FETCH fetch) (PROG ((SUBSTEXPR (CDDDR RECEXPR))) (OR
(MYSUBST (CADR TEM1)) (HELP)))) (HELP))) (RETURN RECEXPR) GLOBAL2
(RETURN (CONS (RECLISPLOOKUP (SETQ TEM1 (CAR (CDDDDR (CAR (CDDDDR
RECEXPR))))) (CADDR RECEXPR) (GETLOCALDEC EXPR FAULTFN) (GETP TEM1
(QUOTE LISPFN))) (CONS (CADDR RECEXPR) FIELD))) GLOBAL (COND (SETQFLG
(RETURN (LIST (QUOTE replace) (QUOTE GLOBAL) RECEXPR FIELD TEM1)))
((NOT (FGETD (SETQ TEM1 (CADDDR (FASSOC FIELD (CDDDR (RECORDECL TEM1)))))))
(HELP)) (T (RETURN (LIST TEM1 RECEXPR)))))))

(RECORDECL
(LAMBDA (DECL DWIMDEFAULT) (PROG (TEM NAME FIELDS DEFAULTS) (OR (LISTP
DECL) (RETURN)) (AND (EQ (CAR DECL) CLISPTRANFLG) (OR (EQ (CADDR DECL)
(QUOTE RECORD)) (EQ (CADDR DECL) (QUOTE TYPERECORD))) (RETURN (
CHECKDEFAULT DWIMDEFAULT (CADR DECL) (CDDR DECL)))) (COND ((AND (NEQ
(CAR DECL) (QUOTE RECORD)) (NEQ (CAR DECL) (QUOTE TYPERECORD))) (RETURN)))
(AND (SETQ TEM (GETHASH DECL CLISPARRAY)) (RETURN (CHECKDEFAULT 
DWIMDEFAULT TEM DECL))) (SETQ DEFAULTS (COND ((OR (EQ (CAR DECL) (QUOTE
TYPERECORD)) (NLISTP (CADR DECL))) (SETQ NAME (CADR DECL)) (SETQ FIELDS
(CADDR DECL)) (CDDDR DECL)) (T (SETQ NAME NIL) (SETQ FIELDS (CADR
DECL)) (CDDR DECL)))) (AND (OR (LISTP NAME) (AND (NEQ (CAR DECL) (QUOTE
TYPERECORD)) (NLISTP FIELDS))) (RECORDERROR "bad record declaration"
NIL DECL)) (SETQ NAME (LIST (SETQ NAME (FIELDSIN FIELDS)) (AND DEFAULTS
(CONS (QUOTE DEFAULTNOTDWIM'D) DEFAULTS)) (COND ((EQ (CAR DECL) (QUOTE
TYPERECORD)) (CONS NIL FIELDS)) (T FIELDS)))) (CLISPTRAN DECL NAME)
(* (RECORD FOO (X . Y) DEFAULT Z:X) watch out for. thus, we put the
default thing afterwards; however -- if there is an error in the DEFAULT
stuff, we'll still have the CLISPTRAN on it; and forevermore not get
the defaults.) (RETURN (CHECKDEFAULT DWIMDEFAULT NAME DECL)))))

(RECCOMPOSE0
(LAMBDA (COMPOSESTATEMENT) (PROG (ALIST CREATE DECL DEF FIELDS TEM
TEMVAR TYPERECORDFLG USING TEM2 USINGTYPE) (* Constructs a composition
of FIELD using things from L - First L must be split up into things
in field) (SETQ CLISPCHANGE T) (* Tell DWIMIFY not to process further)
LPX (COND ((SETQ CREATE (SOME COMPOSESTATEMENT (FUNCTION (LAMBDA (X)
(AND (EQ (CAR (SETQ TEM2 (GETP X (QUOTE CLISPWORD)))) (QUOTE RECORDWORD))
(OR (EQ (SETQ TEM2 (COND ((LISTP (CDR TEM2)) (CADR TEM2)) (T (CDR
TEM2)))) (QUOTE CREATE)) (EQ TEM2 (QUOTE create)))))))) (SETQ FIELDS
(RECORDECL (SETQ DECL (RECLOOK (CADR CREATE) (CDR CREATE) (GETLOCALDEC
EXPR FAULTFN) COMPOSESTATEMENT)) T)))) (COND (TEM (OR CREATE (
RECORDERROR "no CREATE" NIL COMPOSESTATEMENT))) (T (DWIMIFYREC (CDR
COMPOSESTATEMENT) (NCONC (AND CREATE (APPEND (CAR FIELDS) (LIST (CADR
CREATE)))) (APPEND CLISPRECORDWORDS)) COMPOSESTATEMENT) (COND ((NOT
CREATE) (SETQ TEM T) (GO LPX))))) (SETQ DECL (CLISPNOTRAN DECL)) (*
DECL is the actual declaration (used for determining TYPERECORD) and
fields is the hashed declaration - (fieldlist defaults fields ...))
(SETQ TYPERECORDFLG (AND (EQ (CAR DECL) (QUOTE TYPERECORD)) (CADR
DECL))) (SETQ TEM COMPOSESTATEMENT) (SETQ ALIST (MAKEALIST (CAR FIELDS)))
LP2 (COND ((AND (NLISTP (CAR TEM)) (EQ (CAR (SETQ TEM2 (GETP (CAR
TEM) (QUOTE CLISPWORD)))) (QUOTE RECORDWORD)) (SELECTQ (SETQ TEMVAR
(COND ((LISTP (CDR TEM2)) (CADDR TEM2)) (T (CDR TEM2)))) ((CREATE
create) (* already handled) T) ((using copying reusing USING COPYING
REUSING COPYREUSING copyreusing) (AND USING (RECORDERROR (LIST (QUOTE
"both") (CAR TEM) (QUOTE "and") (CAR USING)) TEM COMPOSESTATEMENT))
(SETQ USINGTYPE TEMVAR) (SETQ USING TEM)) NIL)) (SETQ TEM (CDR TEM)))
(T (* GETSETQ adds the info to alist, or ERROR's - let it handle 
unrecognized NLISTP's as well) (GETSETQ TEM ALIST (CAR FIELDS) 
COMPOSESTATEMENT))) (COND ((SETQ TEM (CDR TEM)) (GO LP2))) (SETQ TEMVAR
NIL) (SETQ DEF (RECCOMPOSE1 (COND (TYPERECORDFLG (CDR (CADDR FIELDS)))
(T (CADDR FIELDS))) (AND USING (COND ((NOT (EASYCOMPUTE (CADR USING)))
(SETQ TEMVAR (LIST (LIST (QUOTE $$TEM) (COND (TYPERECORDFLG ('CDR
(CADR USING))) (T (CADR USING)))))) (CAAR TEMVAR)) (TYPERECORDFLG
('CDR (CADR USING))) (T (CADR USING)))))) (COND (TEMVAR (SETQ DEF
(LIST (QUOTE PROG) TEMVAR DEF)))) (/RPLNODE COMPOSESTATEMENT (CAR
CREATE) (CONS (CADR CREATE) (NCONC (COND (USING (LIST (CAR USING)
(CADR USING))) (T NIL)) (SETPACK ALIST)))) (CLISPTRAN COMPOSESTATEMENT
(COND (TYPERECORDFLG ('CONS (KWOTE TYPERECORDFLG) DEF)) (T DEF))))
COMPOSESTATEMENT))

('CAR
(LAMBDA (X) (AND X (PROG (TEM) (COND ((NULL (SETQ TEM (CADR (FASSOC
(CAR X) CRLIST)))) (LIST (QUOTE CAR) X)) (T (LIST TEM (CADR X))))))))

('CDR
(LAMBDA (X) (AND X (PROG (TEM) (COND ((NULL (SETQ TEM (CADDR (FASSOC
(CAR X) CRLIST)))) (LIST (QUOTE CDR) X)) (T (LIST TEM (CADR X))))))))

('CONS
(LAMBDA (CARPART CDRPART) (COND ((OR (EQ (CAR CDRPART) (QUOTE LIST))
(NOT (CAR CDRPART))) (CONS (QUOTE LIST) (CONS CARPART (CDR CDRPART))))
(T (LIST (QUOTE CONS) CARPART CDRPART)))))

(RECCOMPOSE1
(LAMBDA (FIELD DEF) (PROG (K (BLIP (CONS))) (* BLIP is used as a value
of RECCOMPOSE2 when NO field is specified, and something needs to
be returned to distinguish it from NIL (i.e. (CREATE FOO USING FIE
FUM←NIL))) (COND ((NEQ (SETQ K (RECCOMPOSE2 FIELD DEF)) BLIP) (* 
RECCOMPOSE2 returns <expression> to distinguish FIELD←NIL from the
field being not specified) K) (T (* If no USING or COPYING were 
specified, COPYING NIL is assumed; thus RECCOMPOSE returning NIL means
that we had a USING) DEF)))))

(RECCOMPOSE2
(LAMBDA (FIELD DEF CDRFLG) (* Constructs the composition of FIELD
, returning NIL if none of the fields in FIELD are mentioned in the
CREATE expression and there isn't a default for any of the fields
- and <consexpression> otherwise) (PROG (TEM1 TEM2) (COND ((LISTP
FIELD) (SETQ TEM1 (RECCOMPOSE2 (CAR FIELD) ('CAR DEF))) (SETQ TEM2
(RECCOMPOSE2 (CDR FIELD) ('CDR DEF) T)) (* if both are NIL, means
that (1) USING specified; (2) no fields were specified - if only one
is non-NIL, the other comes from USING) (COND ((AND (EQ TEM1 BLIP)
(EQ TEM2 BLIP)) BLIP) (T ('CONS (COND ((NEQ TEM1 BLIP) TEM1) (T (SELECTQ
USINGTYPE ((COPYREUSING copyreusing) (LIST (QUOTE COPY) ('CAR DEF)))
('CAR DEF)))) (COND ((NEQ TEM2 BLIP) TEM2) (T (SELECTQ USINGTYPE ((
COPYREUSING copyreusing) (LIST (QUOTE COPY) ('CDR DEF))) ('CDR DEF))))))))
((AND FIELD (CDR (SETQ TEM1 (FASSOC FIELD ALIST)))) (* The field was
specified - The SUBST here is for special option: (create FOO using
fie field1←< x ! @>) - The @ stands for fie:field1) (COND ((AND 
RECORDSUBSTFLG USINGTYPE) (SUBPAIR (QUOTE @) (SELECTQ USINGTYPE ((
copying COPYING) (LIST (QUOTE COPY) DEF)) DEF) (CADR TEM1))) (T (CADR
TEM1)))) (T (SELECTQ USINGTYPE ((reusing REUSING COPYREUSING copyreusing)
(* Will get def back at higher level when it is discovered that 
"other half" of the CONS is needed) BLIP) ((using USING) DEF) ((copying
COPYING) (LIST (QUOTE COPY) DEF)) (COND ((AND FIELD (CDR (SETQ TEM1
(FASSOC FIELD (CDADR FIELDS))))) (* The field has a default) (CADR
TEM1)) ((OR FIELD (NOT CDRFLG)) (* There is a universal default) (CAADR
FIELDS)) (T NIL))))))))

(MAKECROPFN1
(LAMBDA (RCROPS) (COND ((NULL RCROPS) (QUOTE RECORDFIELDVAR)) ((NULL
(CDDDDR RCROPS)) (LIST (PACK (CONS (QUOTE C) (APPEND RCROPS (QUOTE
(R))))) (QUOTE RECORDFIELDVAR))) (T (LIST (MKATOM (CONCAT (QUOTE C)
(CAR RCROPS) (CADR RCROPS) (CADDR RCROPS) (CADDDR RCROPS) (QUOTE R)))
(MAKECROPFN1 (CDDDDR RCROPS)))))))

(FIELDSIN
(LAMBDA (X) (COND ((NULL X) NIL) ((NLISTP X) (LIST X)) (T (NCONC (
FIELDSIN (CAR X)) (FIELDSIN (CDR X)))))))

(/PUTDTST
(LAMBDA (ATM DEF) (COND ((NOT (FGETD ATM)) (/PUTD ATM DEF)) ((EQUAL
DEF (GETD ATM))) (T (VIRGINFN ATM T) (COND ((NULL DFNFLG) (LISPXPRINT
(CONS ATM (QUOTE (redefined))) T) (SAVEDEF ATM))) (/PUTD ATM DEF)))))

(FIELDDEFS
(LAMBDA (FORMAT RCROPS) (COND ((NULL FORMAT) NIL) ((LISTP FORMAT)
(NCONC (FIELDDEFS (CAR FORMAT) (CONS (QUOTE A) RCROPS)) (FIELDDEFS
(CDR FORMAT) (CONS (QUOTE D) RCROPS)))) ((LITATOM FORMAT) (LIST (LIST
FORMAT (MAKECROPFN1 RCROPS)))) (T (RECORDERROR "Invalid record field"
FORMAT DECL)))))

(MYSUBST
(LAMBDA (SEXPR) (* SUBSTS EXPR::3 for (RECORDFIELDVAR) IN SEXPR returns
NIL if RECORDFIELDVAR not found) (COND ((NLISTP SEXPR) NIL) ((EQ (CAR
SEXPR) (QUOTE RECORDFIELDVAR)) SUBSTEXPR) (T (PROG ((A (MYSUBST (CAR
SEXPR))) (D (MYSUBST (CDR SEXPR)))) (AND (NULL A) (NULL D) (RETURN))
(CONS (OR A (CAR SEXPR)) (OR D (CDR SEXPR))))))))

(MAKERPLAC2
(LAMBDA (FORM) (PROG (TEM) (OR (SETQ TEM (CDDDR (FASSOC (CAR FORM)
CRLIST))) (HELP)) (CONS (SELECTQ (CAR TEM) (CAR (QUOTE RPLACA)) (CDR
(QUOTE RPLACD)) (HELP)) (CONS (COND ((CADR TEM) (LIST (CADR TEM) (CADR
FORM))) (T (CADR FORM))) (QUOTE (VALUE)))))))

(RECRESPELL
(LAMBDA (FIELD DECLST TAIL) (FIXSPELL FIELD 70 (NCONC (MAPCONC DECLST
(FUNCTION (LAMBDA (X) (APPEND (CAR (RECORDECL X)))))) RECORDSPLIST)
NIL TAIL NIL T)))

(CLISPNOTRAN
(LAMBDA (X) (COND ((AND (LISTP X) (EQ (CAR X) CLISPTRANFLG)) (CDDR
X)) (T X))))

(GETLOCALDEC
(LAMBDA (EXPR FN) (PROG (TEM) (RETURN (COND ((AND (EQ (CAR (SETQ TEM
(CADDR EXPR))) (QUOTE *)) (EQ (CADR TEM) (QUOTE DECLARATIONS:))) (CDDR
TEM)) ((EQ (CAR TEM) (QUOTE CLISP:)) (CLISPDEC0 TEM (OR FN FAULTFN)))))))
)

(RECLOOK
(LAMBDA (RECNAME TAIL LOCALDEC PARENT) (* LOOKS FOR RECORD DECLARATION)
(PROG (TEM) RETRY (OR (COND ((NLISTP RECNAME) (OR (AND LOCALDEC (
CLISPLOOKUP0 RECNAME NIL NIL LOCALDEC NIL (QUOTE RECORD))) (GETP RECNAME
(QUOTE CLISPRECORD)) (COND ((SETQ TEM (FIXSPELL RECNAME 70 (NCONC
(MAPCONC LOCALDEC (FUNCTION (LAMBDA (X) (AND (OR (EQ (CAR X) (QUOTE
TYPERECORD)) (EQ (CAR X) (QUOTE RECORD)) (EQ (CAR X) CLISPTRANFLG))
(NLISTP (CADR X)) (LIST (CADR X)))))) USERRECORDS) NIL TAIL NIL T))
(SETQ RECNAME TEM) (GO RETRY))))) ((OR (EQ (CAR RECNAME) (QUOTE RECORD))
(EQ (CAR RECNAME) (QUOTE TYPERECORD)) (AND (EQ (CAR RECNAME) 
CLISPTRANFLG) (FMEMB (CADDR RECNAME) (QUOTE (RECORD TYPERECORD)))))
RECNAME)) (RECORDERROR (CONCAT RECNAME " not a record") NIL PARENT)))))

(DWIMIFYREC
(LAMBDA (TAIL NEWVARS PARENT) (PROG ((VARS (APPEND NEWVARS VARS)))
(AND RECORDSUBSTFLG (SETQ VARS (CONS (QUOTE @) VARS))) (DWIMIFY1B
TAIL PARENT TAIL T NIL FAULTFN))))

(EASYCOMPUTE
(LAMBDA (X) (OR (NLISTP X) (AND (SELECTQ (CAR X) ((CAR CDR) T) (GETP
(CAR X) (QUOTE CROPS))) (NLISTP (CADR X))))))

(GLOBALRECORD
(LAMBDA (FIELD) (PROG (TEM CLASS) (FRPLACD (CDR FIELD) (LIST (MAKERPLAC2
(CADR FIELD)) (PACK (LIST (QUOTE GET.) (CAR FIELD))) (PACK (LIST (QUOTE
REPLACE.) (CAR FIELD))) (PACK (LIST (QUOTE /REPLACE.) (CAR FIELD)))
(PACK (LIST (QUOTE FREPLACE.) (CAR FIELD))))) (* NOW FIELD IS (NAME
DEF RPLDEF GETFN PUTFN /PUTFN FPUTFN)) (SETQ TEM (/PUT (CADDDR FIELD)
(QUOTE MACRO) (LIST (QUOTE (RECORDFIELDVAR)) (CADR FIELD)))) (/PUTDTST
(CADDDR FIELD) (OR (AND (NLISTP (CADADR FIELD)) (GETD (CAADR FIELD)))
(CONS (QUOTE LAMBDA) TEM))) (/PUT (CAR FIELD) (QUOTE ACCESSFN) (CONS
(CADDDR FIELD) (CAR (CDDDDR FIELD)))) (/PUT (CADDDR FIELD) (QUOTE
ACCESSFN) (CAR FIELD)) (SETQ TEM (SELECTQ (CAR (CADDR FIELD)) (RPLACA
(QUOTE (RPLACA /RPLACA FRPLACA))) (RPLACD (QUOTE (RPLACD /RPLACD FRPLACD)))
(HELP))) (/PUT (CAR (CDDDDR FIELD)) (QUOTE LISPFN) (SELECTQ (GETP
(QUOTE RPLACA) (QUOTE LISPFN)) (RPLACA (CAR (CDDDDR FIELD))) (/RPLACA
(CADR (CDDDDR FIELD))) (FRPLACA (CADDR (CDDDDR FIELD))) (HELP))) (/PUT
(CAR (CDDDDR FIELD)) (QUOTE CLISPCLASSDEF) (CONS (QUOTE ACCESS) (CDDDDR
FIELD))) (FOR X IN TEM AS Y IN (CDDDDR FIELD) DO (SETQ TEM (LIST (QUOTE
(RECORDFIELDVAR VALUE)) (CONS X (CDR (CADDR FIELD))))) (/PUTDTST Y
(OR (AND (NLISTP (CADR (CADDR FIELD))) (GETD X)) (CONS (QUOTE LAMBDA)
TEM))) (/PUT Y (QUOTE LISPFN) (CAR (CDDDDR FIELD))) (/PUT Y (QUOTE
MACRO) TEM) (/PUT Y (QUOTE ACCESSFN) (CONS (CAR FIELD) Y))))))

(RECLISPLOOKUP
(LAMBDA (WORD VAR1 DECLST LISPFN) (PROG (CLASS) (COND ((AND (SETQ
CLASS (GETP WORD (QUOTE CLISPCLASS))) DECLST) (CLISPLOOKUP0 WORD VAR1
NIL DECLST LISPFN CLASS)) (T (OR LISPFN WORD))))))

(GETSETQ
(LAMBDA (TAIL ALIST FIELDS PARENT) (PROG (TEM1) LP2 (RECORDERROR (COND
((LISTP (CAR TAIL)) (OR (SELECTQ (CAAR TAIL) ((SETQ SAVESETQ) (OR
(CDDR (CAR TAIL)) (/RPLACD (CDAR TAIL) (CONS))) NIL) ((SETQQ SAVESETQQ)
(/RPLNODE (CAR TAIL) (QUOTE SETQ) (LIST (CADAR TAIL) (KWOTE (CADDR
(CAR TAIL))))) NIL) (QUOTE NOFIELD)) (COND ((SETQ TEM1 (FASSOC (CADAR
TAIL) ALIST)) (COND ((CDR TEM1) "field specified twice") (T (RETURN
(FRPLACD TEM1 (CDDAR TAIL)))))) ((FIXSPELL (CADAR TAIL) 70 FIELDS
NIL (CDAR TAIL) NIL T) (GO LP2)) (T (QUOTE FIELDS))))) ((AND (FMEMB
(CAR TAIL) FIELDS) (COND ((AND (LISTP (CADR TAIL)) (FMEMB (CAADR TAIL)
(QUOTE (SETQ SETQQ SAVESETQ SAVESETQQ)))) (NOT (FMEMB (CADR (CADR
TAIL)) FIELDS))) (T T))) (/RPLNODE TAIL (LIST (QUOTE SETQ) (CAR TAIL)
(CADR TAIL)) (CDDR TAIL)) (GO LP2)) (T (QUOTE NOFIELDS))) (CDR TAIL)
PARENT))))

(RECORDERROR
(LAMBDA (MESSAGE AT IN) (CLISPERROR (LIST (SELECTQ MESSAGE (NOFIELDS
"missing 'field←'") (FIELDS "unrecognized field←") MESSAGE) AT IN)
T) (* Tell it that this is an external call) (ERROR!)))

(SETPACK
(LAMBDA (ALIST) (for TEM in ALIST when (CDR TEM) join (LIST (PACK
(LIST (CAR TEM) (QUOTE ←))) (CADR TEM)))))

(MAKEALIST
(LAMBDA (LST) (MAPCAR LST (FUNCTION (LAMBDA (X) (LIST X))))))

(CHECKDEFAULT
(LAMBDA (CHKFLG TRAN DECL) (AND CHKFLG (CADR TRAN) (EQ (CAADR TRAN)
(QUOTE DEFAULTNOTDWIM'D)) (PROG (ALIST (TEM (CDADR TRAN))) (DWIMIFYREC
TEM (CONS (QUOTE DEFAULT) (APPEND (CAR TRAN) NIL)) DECL) (SETQ ALIST
(CONS (LIST (QUOTE DEFAULT)) (MAKEALIST (CAR TRAN)))) LP (COND ((EQ
(CAR TEM) (QUOTE DEFAULT))) (T (GETSETQ TEM ALIST (CONS (QUOTE DEFAULT)
(CAR TRAN)) DECL))) (COND ((SETQ TEM (CDR TEM)) (GO LP))) (/RPLNODE
(CDADR TRAN) (QUOTE DEFAULT) (APPEND (COND ((CDAR ALIST) (LIST (QUOTE
←) (CADAR ALIST)))) (SETPACK (CDR ALIST)))) (FRPLACA (CDR TRAN) (CONS
(CADAR ALIST) (CDR ALIST))))) TRAN))
)
(DEFLIST(QUOTE(
(CREATE (RECORDWORD . create))
(create (RECORDWORD . create))
(USING (RECORDWORD . using))
(using (RECORDWORD . using))
))(QUOTE CLISPWORD))

(DEFLIST(QUOTE(
(RECORDS (LAMBDA (X Y) (AND (EQ (CAR X) Y) (CDR X))))
))(QUOTE PRETTYTYPE))

(ADDTOVAR PRETTYTYPELST (CHANGEDRECLST RECORDS "records"))
(ADDTOVAR PRETTYMACROS (RECORDS X (E (MAPC (QUOTE X) (FUNCTION (LAMBDA
(Z) (PRINT (SELECTQ (CAR (SETQ Z (CLISPNOTRAN (OR (LISTP Z) (LISTP
(GETP Z (QUOTE RECORD))))))) ((RECORD TYPERECORD) Z) (ERROR Z 
"not a record")))))))))
(RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL) (CDR CADR CDDR CDR NIL) (CDDDDR
NIL NIL CDR CDDDR) (CADDDR NIL NIL CAR CDDDR) (CDDDR CADDDR CDDDDR
CDR CDDR) (CDADDR NIL NIL CDR CADDR) (CAADDR NIL NIL CAR CADDR) (CADDR
CAADDR CDADDR CAR CDDR) (CDDR CADDR CDDDR CDR CDR) (CDDADR NIL NIL
CDR CDADR) (CADADR NIL NIL CAR CDADR) (CDADR CADADR CDDADR CDR CADR)
(CDAADR NIL NIL CDR CAADR) (CAAADR NIL NIL CAR CAADR) (CAADR CAAADR
CDAADR CAR CADR) (CADR CAADR CDADR CAR CDR) (CDDDAR NIL NIL CDR CDDAR)
(CADDAR NIL NIL CAR CDDAR) (CDDAR CADDAR CDDDAR CDR CDAR) (CDADAR
NIL NIL CDR CADAR) (CAADAR NIL NIL CAR CADAR) (CADAR CAADAR CDADAR
CAR CDAR) (CDAR CADAR CDDAR CDR CAR) (CDDAAR NIL NIL CDR CDAAR) (CADAAR
NIL NIL CAR CDAAR) (CDAAR CADAAR CDDAAR CDR CAAR) (CDAAAR NIL NIL
CDR CAAAR) (CAAAAR NIL NIL CAR CAAAR) (CAAAR CAAAAR CDAAAR CAR CAAR)
(CAAR CAAAR CDAAR CAR CAR)))
(RPAQ RECORDSPLIST (LIST NIL))
(RPAQ CHANGEDRECLST NIL)
(RPAQ USERRECORDS NIL)
(RPAQ RECORDTRANFLG T)
(RPAQQ RECORDREPLACEVALUEFLG T)
(RPAQQ CLISPRECORDWORDS (CREATE USING COPYING REUSING create using
copying reusing))
(RPAQ RECORDSUBSTFLG T)
(DECLARE
(BLOCK: RECORDBLOCK TYPERECORD RECORD RECORD1 CLISPRECORD RECORDECL
CHECKDEFAULT RECCOMPOSE0 'CAR 'CDR 'CONS RECCOMPOSE1 RECCOMPOSE2 
MAKECROPFN1 FIELDSIN /PUTDTST FIELDDEFS MYSUBST MAKERPLAC2 RECRESPELL
CLISPNOTRAN GETLOCALDEC RECLOOK DWIMIFYREC EASYCOMPUTE GLOBALRECORD
RECLISPLOOKUP GETSETQ RECORDERROR SETPACK MAKEALIST (ENTRIES RECORD
TYPERECORD RECCOMPOSE0 CLISPRECORD RECORDECL) (LOCALFREEVARS SUBSTEXPR
ALIST BLIP COPYING FIELDS DECL USINGTYPE) (GLOBALVARS CHANGEDRECLST
CLISPARRAY CLISPTRANFLG CRLIST DFNFLG DWIMFLG FILEPKGFLG 
RECORDREPLACEVALUEFLG RECORDSPLIST RECORDTRANFLG USERRECORDS 
CLISPRECORDWORDS RECORDSUBSTFLG) (SPECVARS VARS REDECLARELST))
(BLOCK: NIL CLISPNOTRAN (LINKEDFN . T))
)STOP